home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / nan_news / toolkit / savearr.prg < prev    next >
Text File  |  1991-08-15  |  7KB  |  266 lines
  1. /*
  2.  * File......: SAVEARR.PRG
  3.  * Author....: David Barrett
  4.  * CIS ID....: 72037,105
  5.  * Date......: $Date:   15 Aug 1991 23:06:06  $
  6.  * Revision..: $Revision:   1.2  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/savearr.prv  $
  8.  *
  9.  * This is an original work by David Barrett and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/savearr.prv  $
  16.  * 
  17.  *    Rev 1.2   15 Aug 1991 23:06:06   GLENN
  18.  * Forest Belt proofread/edited/cleaned up doc
  19.  * 
  20.  *    Rev 1.1   14 Jun 1991 19:52:54   GLENN
  21.  * Minor edit to file header
  22.  * 
  23.  *    Rev 1.0   07 Jun 1991 23:39:38   GLENN
  24.  * Initial revision.
  25.  *
  26.  *
  27.  */
  28.  
  29.  
  30.  
  31. MEMVAR lRet
  32.  
  33. #ifdef FT_TEST              // test program to demonstrate functions
  34.  
  35.  LOCAL  aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T.},;
  36.                 {'Invoice 2', DATE(), 234.98, .F.},;
  37.                 {'Invoice 3', DATE() + 1, 0, .T.}  }, aSave
  38.  LOCAL nErrorCode := 0
  39.  FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  40.  IF nErrorCode = 0
  41.    CLS
  42.    DispArray(aArray)
  43.    aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  44.    IF nErrorCode = 0
  45.      DispArray(aSave)
  46.    ELSE
  47.       ? 'Error restoring array'
  48.    ENDIF
  49.  ELSE
  50.    ? 'Error writing array'
  51.  ENDIF
  52.  RETURN
  53.  
  54.  FUNCTION DispArray(aTest)
  55.    LOCAL nk
  56.    FOR nk := 1 TO LEN(aTest)
  57.      ? aTest[nk, 1]
  58.      ?? '  '
  59.      ?? DTOC(aTest[nk, 2])
  60.      ?? '  '
  61.      ?? STR(aTest[nk, 3])
  62.      ?? '  '
  63.      ?? IF(aTest[nk, 4], 'true', 'false')
  64.    NEXT
  65.  RETURN Nil
  66. #endif
  67.  
  68.  
  69.  
  70.  
  71. /*  $DOC$
  72.  *  $FUNCNAME$
  73.  *     FT_SAVEARR()
  74.  *  $CATEGORY$
  75.  *     Array
  76.  *  $ONELINER$
  77.  *     Save Clipper array to a disc file.
  78.  *  $SYNTAX$
  79.  *     FT_SAVEARR( <aArray>, <cFileName>, <nErrorCode> ) -> lRet
  80.  *  $ARGUMENTS$
  81.  *     <aArray> is any Clipper array except those containing
  82.  *     compiled code blocks.
  83.  *
  84.  *     <cFileName> is a DOS file name.
  85.  *
  86.  *     <nErrorCode> will return any DOS file error.
  87.  *
  88.  *     All arguments are required.
  89.  *
  90.  *  $RETURNS$
  91.  *     .F. if there was a DOS file error or the array contained
  92.  *     code blocks, otherwise returns .T.
  93.  *  $DESCRIPTION$
  94.  *     FT_SAVEARR() saves any Clipper array, except those
  95.  *     containing compiled code blocks, to a disc file.  The
  96.  *     array can be restored from the disc file using
  97.  *     FT_RESTARR().
  98.  *
  99.  *  $EXAMPLES$
  100.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  101.  *                {'Invoice 2',DATE(),234.98,.F.},;
  102.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  103.  *    nErrorCode := 0
  104.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  105.  *    IF nErrorCode = 0
  106.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  107.  *      IF nErrorCode # 0
  108.  *         ? 'Error restoring array'
  109.  *      ENDIF
  110.  *    ELSE
  111.  *      ? 'Error writing array'
  112.  *    ENDIF
  113.  *
  114.  *  $SEEALSO$
  115.  *     FT_RESTARR()
  116.  *  $END$
  117.  */
  118.  
  119.  
  120. FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
  121.  LOCAL nHandle, lRet
  122.  nHandle = FCREATE(cFileName)
  123.  nErrorCode = FError()
  124.  IF nErrorCode = 0
  125.    lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
  126.    FCLOSE(nHandle)
  127.    IF (lRet) .AND. (FERROR() # 0)
  128.       nErrorCode = FERROR()
  129.       lRet = .F.
  130.     ENDIF
  131.  ELSE
  132.    lRet = .F.
  133.  ENDIF
  134.  RETURN lRet
  135.  
  136. STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
  137.  LOCAL cValType, nLen, cString
  138.  PRIVATE lRet       // accessed in code block
  139.  lRet := .T.
  140.  cValType := ValType(xMemVar)
  141.  FWrite(nHandle, cValType, 1)
  142.  IF FError() = 0
  143.    DO CASE
  144.      CASE cValType = "A"
  145.        nLen := Len(xMemVar)
  146.        FWrite(nHandle, L2Bin(nLen), 4)
  147.        IF FError() = 0
  148.          AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
  149.        ELSE
  150.          lRet = .F.
  151.        ENDIF
  152.      CASE cValType = "B"
  153.        lRet := .F.
  154.      CASE cValType = "C"
  155.        nLen := Len(xMemVar)
  156.        FWrite(nHandle, L2Bin(nLen), 4)
  157.        FWrite(nHandle, xMemVar)
  158.      CASE cValType = "D"
  159.        nLen := 8
  160.        FWrite(nHandle, L2Bin(nLen), 4)
  161.        FWrite(nHandle, DTOC(xMemVar))
  162.      CASE cValType = "L"
  163.        nLen := 1
  164.        FWrite(nHandle, L2Bin(nLen), 4)
  165.        FWrite(nHandle, IF(xMemVar, "T", "F") )
  166.      CASE cValType = "N"
  167.        cString := STR(xMemVar)
  168.        nLen := LEN(cString)
  169.        FWrite(nHandle, L2Bin(nLen), 4)
  170.        FWrite(nHandle, cString)
  171.    ENDCASE
  172.  ELSE
  173.    lRet = .F.
  174.  ENDIF
  175.  nErrorCode = FError()
  176.  RETURN lRet
  177.  
  178.  
  179. /*  $DOC$
  180.  *  $FUNCNAME$
  181.  *     FT_RESTARR()
  182.  *  $CATEGORY$
  183.  *     Array
  184.  *  $ONELINER$
  185.  *     Restore a Clipper array from a disc file
  186.  *  $SYNTAX$
  187.  *     FT_RESTARR( <cFileName>, <nErrorCode> ) -> aArray
  188.  *  $ARGUMENTS$
  189.  *     <cFileName> is a DOS file name.
  190.  *
  191.  *     <nErrorCode> will return any DOS file error.
  192.  *
  193.  *     All arguments are required.
  194.  *  $RETURNS$
  195.  *     Return an array variable.
  196.  *  $DESCRIPTION$
  197.  *     FT_RESTARR() restores an array which was saved to
  198.  *     a disc file using FT_SAVEARR().
  199.  *
  200.  *  $EXAMPLES$
  201.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  202.  *                {'Invoice 2',DATE(),234.98,.F.},;
  203.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  204.  *    nErrorCode := 0
  205.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  206.  *    IF nErrorCode = 0
  207.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  208.  *      IF nErrorCode # 0
  209.  *         ? 'Error restoring array'
  210.  *      ENDIF
  211.  *    ELSE
  212.  *      ? 'Error writing array'
  213.  *    ENDIF
  214.  *
  215.  *  $SEEALSO$
  216.  *     FT_SAVEARR()
  217.  *  $END$
  218.  */
  219.  
  220. FUNCTION FT_RESTARR(cFileName, nErrorCode)
  221.  LOCAL nHandle, aArray
  222.  nHandle := FOPEN(cFileName)
  223.  nErrorCode := FError()
  224.  IF nErrorCode = 0
  225.   aArray := _ftrestsub(nHandle, @nErrorCode)
  226.   FCLOSE(nHandle)
  227.  ELSE
  228.    aArray := {}
  229.  ENDIF
  230.  RETURN aArray
  231.  
  232. STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
  233.   LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
  234.   cValType := ' '
  235.   FREAD(nHandle, @cValType, 1)
  236.   cLenStr := SPACE(4)
  237.   FREAD(nHandle, @cLenStr, 4)
  238.   nLen = Bin2L(cLenStr)
  239.   nErrorCode = FError()
  240.   IF nErrorCode = 0
  241.     DO CASE
  242.       CASE cValType = "A"
  243.         xMemVar := {}
  244.         FOR nk := 1 TO nLen
  245.           AADD(xMemVar, _ftrestsub(nHandle))      // Recursive call
  246.         NEXT
  247.       CASE cValType = "C"
  248.         xMemVar := SPACE(nLen)
  249.         FREAD(nHandle, @xMemVar, nLen)
  250.       CASE cValType = "D"
  251.         cMemVar = SPACE(8)
  252.         FREAD(nHandle, @cMemVar,8)
  253.         xMemVar := CTOD(cMemVar)
  254.       CASE cValType = "L"
  255.         cMemVar := ' '
  256.         FREAD(nHandle, @cMemVar, 1)
  257.         xMemVar := (cMemVar =  "T")
  258.       CASE cValType = "N"
  259.         cMemVar := SPACE(nLen)
  260.         FREAD(nHandle, @cMemVar, nLen)
  261.         xMemVar = VAL(cMemVar)
  262.     ENDCASE
  263.     nErrorCode := FERROR()
  264.   ENDIF
  265.   RETURN xMemVar
  266.